home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / recovery.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  47.8 KB  |  1,325 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: WOOD -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; recovery.lisp
  6. ;; Support logging/recovery for WOOD.
  7. ;;
  8. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  9. ;; Permission is given to use, copy, and modify this software provided
  10. ;; that this copyright notice is attached to all derivative works.
  11. ;; This software is provided "as is". Apple makes no warranty or
  12. ;; representation, either express or implied, with respect to this software,
  13. ;; its quality, accuracy, merchantability, or fitness for a particular
  14. ;; purpose.
  15.  
  16. ;;
  17. ;; To do:
  18. ;;
  19. ;; Remember most recently consed object so that undo
  20. ;; bytes are unnecessary for subsequent stores into that object.
  21.  
  22. (in-package :wood)
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;
  26. ;; Modification History
  27. ;;
  28. ;; -------------- 0.5
  29. ;; 05/27/92 bill  New file
  30. ;;
  31.  
  32. #|
  33. Format of a log file:
  34. =========
  35. <Entry 0>      ; first log entry
  36. ...
  37. <Entry n>      ; last log entry
  38. =========
  39.  
  40. Format of a log entry:
  41. =========
  42. <Type>         ; one byte. The type of entry
  43. <Data>         ; entry type specific
  44. =========
  45.  
  46.  
  47. Format of data types written in log:
  48.  
  49. <byte>         ; 8 bits of data
  50. <word>         ; 2 <byte>s
  51. <long>         ; 4 <byte>s
  52. <length>       ; 1 or more bytes. Each contains 7 bits of data.
  53.                ; If the MSB of a byte is set, there are more bytes
  54. <string>       ; <length><data> - <data> is <length> bytes
  55.  
  56.  
  57. Entry descriptions:
  58.  
  59. Header. The first entry in a log file:
  60. =========
  61. $log-header-type                 ; <byte>
  62. $log-version                     ; <byte>
  63. <EOF>                            ; <long> - End of file address
  64. <checkpoint>                     ; LSN of last checkpoint record
  65. <log for>                        ; <string> - Name of file that this
  66.                                  ; one is logging. Assumed to be in
  67.                                  ; the same directory as the log file.
  68. =========
  69.  
  70. Begin transaction:
  71. =========
  72. $begin-transaction-type          ; <byte>
  73. <parent LSN>                     ; <long> - LSN of parent transaction or 0
  74. =========
  75.  
  76. Continue transaction.
  77. A Continue transaction record is written when a different
  78. transaction needs to write log records.
  79. =========
  80. $continue-transaction-type       ; <byte>
  81. <LSN>                            ; <long>
  82. =========
  83.  
  84. Abort transaction:
  85. =========
  86. $abort-transaction-type          ; <byte>
  87. <LSN>                            ; <long>
  88. =========
  89.  
  90. Commit transaction:
  91. =========
  92. $commit-transaction-type         ; <byte>
  93. <LSN>                            ; <long>
  94. =========
  95.  
  96. Checkpoint:
  97. =========
  98. $checkpoint-type                 ; <byte>
  99. <open transaction count>         ; <length>
  100. <lsn 0>                          ; <long>
  101. ...
  102. <lsn n>                          ; <long>
  103. =========
  104.  
  105. There are 2 basic kinds of data entries: with and without undo.
  106. Eventually, we may want to work at encoding the address as a
  107. byte or word, offset from the past address written to the log.
  108. This poses problems for undo, however, as undo parses the log
  109. backwards.
  110.  
  111. Write data without undo:
  112. =========
  113. <type>                           ; <byte>
  114. <address>                        ; <long>
  115. <size>                           ; <length> (optional) size of data
  116. <data>
  117. =========
  118.  
  119. Write data with undo:
  120. =========
  121. <type>                           ; <byte>
  122. <undo-link>                      ; <length> - negative offset to last undo
  123. <address>                        ; <long>
  124. <size>                           ; <length> (optional) size of data
  125. <old data>
  126. <new data>
  127. =========
  128.  
  129. Write byte:
  130. =========
  131. $write-byte                      ; <byte>
  132. <address>                        ; <long>
  133. <data>                           ; <byte>
  134. =========
  135.  
  136. Write byte with undo:
  137. =========
  138. $write-byte-with-undo            ; <byte>
  139. <undo-link)                      ; <length>
  140. <address>                        ; <long>
  141. <old data>                       ; <byte>
  142. <new data>                       ; <byte>
  143. =========
  144.  
  145. Write word:
  146. =========
  147. $write-word                      ; <byte>
  148. <address>                        ; <long>
  149. <data>                           ; <word>
  150. =========
  151.  
  152. Write word with undo:
  153. =========
  154. $write-word-with-undo            ; <byte>
  155. <undo-link)                      ; <length>
  156. <address>                        ; <long>
  157. <old data>                       ; <word>
  158. <new data>                       ; <word>
  159. =========
  160.  
  161. Write long:
  162. =========
  163. $write-long                      ; <byte>
  164. <address>                        ; <long>
  165. <data>                           ; <long>
  166. =========
  167.  
  168. Write long with undo:
  169. =========
  170. $write-long-with-undo            ; <byte>
  171. <undo-link)                      ; <length>
  172. <address>                        ; <long>
  173. <old data>                       ; <long>
  174. <new data>                       ; <long>
  175. =========
  176.  
  177. Write bytes:
  178. =========
  179. $write-bytes                     ; <byte>
  180. <address>                        ; <long>
  181. <size>                           ; <length>
  182. <data>                           ; <size> <byte>s
  183. =========
  184.  
  185. write bytes with undo:
  186. =========
  187. $write-bytes-with-undo           ; <byte>
  188. <undo-link>                      ; <length>
  189. <address>                        ; <long>
  190. <size>                           ; <length>
  191. <old data>                       ; <size> <byte>s
  192. <new data>                       ; <size> <byte>s
  193. =========
  194.  
  195. Fill bytes:
  196. =========
  197. $fill-byte                       ; <byte>
  198. <address>                        ; <long>
  199. <count>                          ; <length>
  200. <data>                           ; <byte>
  201. =========
  202.  
  203. Fill bytes with undo:
  204. =========
  205. $fill-byte-with-undo             ; <byte>
  206. <undo-link>                      ; <length>
  207. <address>                        ; <long>
  208. <count>                          ; <length>
  209. <old data>                       ; <count> <byte>s
  210. <new data>                       ; <byte>
  211. =========
  212.  
  213. Fill word:
  214. =========
  215. $fill-word                       ; <byte>
  216. <address>                        ; <long>
  217. <count>                          ; <length>
  218. <data>                           ; <word>
  219. =========
  220.  
  221. Fill word with undo:
  222. =========
  223. $fill-word-with-undo             ; <byte>
  224. <undo-link>                      ; <length>
  225. <address>                        ; <long>
  226. <count>                          ; <length>
  227. <old data>                       ; <count> <word>s
  228. <new data>                       ; <word>
  229. =========
  230.  
  231. Fill long:
  232. =========
  233. $fill-long                       ; <byte>
  234. <address>                        ; <long>
  235. <count>                          ; <length>
  236. <data>                           ; <long>
  237. =========
  238.  
  239. Fill long with undo:
  240. =========
  241. $fill-long-with-undo             ; <byte>
  242. <undo-link>                      ; <length>
  243. <address>                        ; <long>
  244. <count>                          ; <length>
  245. <old data>                       ; <count> <long>s
  246. <new data>                       ; <long>
  247. =========
  248.  
  249. |#
  250.  
  251. (defconstant $log-header-type #xfe)
  252. (defconstant $log-version 1)
  253. (defconstant $log-min-version 1)        ; the minimum version we can handle
  254. (defconstant $log-eof-address 2)
  255. (defconstant $log-checkpoint-address 6)
  256.  
  257. (defconstant $begin-transaction-type    1)
  258. (defconstant $continue-transaction-type 2)
  259. (defconstant $abort-transaction-type    3)
  260. (defconstant $commit-transaction-type   4)
  261. (defconstant $write-byte                5)
  262. (defconstant $write-byte-with-undo      6)
  263. (defconstant $write-word                7)
  264. (defconstant $write-word-with-undo      8)
  265. (defconstant $write-long                9)
  266. (defconstant $write-long-with-undo     10)
  267. (defconstant $write-bytes              11)
  268. (defconstant $write-bytes-with-undo    12)
  269. (defconstant $fill-byte                13)
  270. (defconstant $fill-byte-with-undo      14)
  271. (defconstant $fill-word                15)
  272. (defconstant $fill-word-with-undo      16)
  273. (defconstant $fill-long                17)
  274. (defconstant $fill-long-with-undo      18)
  275. (defconstant $checkpoint-type          19)
  276.  
  277. ; tables at bottom of file
  278. (declaim (special *log-type->name* *log-undo-functions*))
  279.  
  280. (defun log-type->name (log-type)
  281.   (svref *log-type->name* log-type))
  282.  
  283. ; A dc-log is used for logging writes to a disk-cache.
  284. ; It keeps the current output page locked so that entries
  285. ; can be made quickly.
  286. (defstruct (dc-log (:print-function print-dc-log))
  287.   log-for                               ; the disk-cache I'm logging
  288.   disk-cache                            ; the disk-cache for the log file
  289.   page                                  ; the disk-page for page-buffer
  290.   buffer                                ; one block of log bytes
  291.   (ptr 0)                               ; index into page-buffer
  292.   (bytes-left 0)                        ; number of bytes after ptr
  293.   modified                              ; true if we've written in the page
  294.   page-0                                ; first page - for EOF & last checkpoint
  295.   buffer-0                              ; and it's buffer
  296.   (eof 0)                               ; End of file if PTR not at EOF
  297.   active-transactions                   ; list of LSN's
  298.   )
  299.  
  300. (defun print-dc-log (dc-log stream level)
  301.   (declare (ignore level))
  302.   (let* ((log-for (dc-log-log-for dc-log))
  303.          (log-for-stream (and log-for (disk-cache-stream log-for)))
  304.          (log-for-path (and log-for-stream (pathname log-for-stream)))
  305.          (dc (dc-log-disk-cache dc-log))
  306.          (dc-stream (and dc (disk-cache-stream dc)))
  307.          (dc-path (and dc-stream (pathname dc-stream))))
  308.     (print-unreadable-object (dc-log stream :type t :identity t)
  309.       (let ((pos (log-position dc-log)))
  310.         (prin1 pos stream)
  311.         (write-char #\/ stream)
  312.         (prin1 (max pos (dc-log-eof dc-log)) stream))
  313.       (when (or log-for-path dc-path)
  314.         (write-char #\space stream)
  315.         (prin1 dc-path stream)
  316.         (write-char #\space stream)
  317.         (prin1 log-for-path stream)))))
  318.  
  319. ; Open a disk-cache log
  320. ; filename is a string or pathname
  321. ; log-for is a disk-cache
  322. (defun open-dc-log (filename log-for &key 
  323.                              (if-exists :overwrite)
  324.                              (if-does-not-exist :create))
  325.   (let ((check-header? (and (probe-file filename) (eq if-exists :overwrite)))
  326.         (disk-cache (open-disk-cache filename
  327.                                      :if-exists if-exists
  328.                                      :if-does-not-exist if-does-not-exist))
  329.         (log-for-name (file-namestring (disk-cache-stream log-for)))
  330.         dc-log)
  331.     (when disk-cache
  332.       (setq dc-log (make-dc-log :log-for log-for
  333.                                 :disk-cache disk-cache))
  334.       (if check-header?
  335.         (progn
  336.           (log-position dc-log 0)
  337.           (let ((page (dc-log-page dc-log)))
  338.             (lock-page page)            ; extra lock to keep page-0 swapped in
  339.             (setf (dc-log-page-0 dc-log) page
  340.                   (dc-log-buffer-0 dc-log) (dc-log-buffer dc-log)))
  341.           (unless (eql $log-header-type (log-read-byte dc-log))
  342.             (error "Bad log header in ~s" dc-log))
  343.           (unless (<= $log-min-version (log-read-byte dc-log) $log-version)
  344.             (error "Bad log version in ~s" dc-log))
  345.           (let* ((eof (log-read-long dc-log))
  346.                  (checkpoint (log-read-long dc-log))
  347.                  (dc-log-for-name (log-read-string dc-log)))
  348.             (declare (ignore checkpoint))            (setf (dc-log-eof dc-log) eof)
  349.             (unless (equalp log-for-name dc-log-for-name)
  350.               (cerror "Ignore this problem."
  351.                       "~s is a log for ~s, not ~s"
  352.                       dc-log dc-log-for-name log-for-name))
  353.             (log-position dc-log eof)))
  354.         (progn
  355.           (unless (eql 0 (disk-cache-size disk-cache))
  356.             (error "~s is not empty." disk-cache))
  357.           (log-extend dc-log)
  358.           (log-position dc-log 0)
  359.           (let ((page (dc-log-page dc-log)))
  360.             (lock-page page)            ; extra lock to keep page-0 swapped in
  361.             (setf (dc-log-page-0 dc-log) page
  362.                   (dc-log-buffer-0 dc-log) (dc-log-buffer dc-log)))
  363.           (log-write-byte dc-log $log-header-type)
  364.           (log-write-byte dc-log $log-version)
  365.           (log-write-long dc-log 0)     ; eof
  366.           (log-write-long dc-log 0)     ; checkpoint
  367.           (log-write-string dc-log log-for-name t)
  368.           (setf (dc-log-eof dc-log) (log-position dc-log))))
  369.       dc-log)))
  370.  
  371. (defun close-dc-log (dc-log &optional ignore-active-transactions)
  372.   (let ((disk-cache (dc-log-disk-cache dc-log)))
  373.     (when disk-cache
  374.       (force-log dc-log)
  375.       (unless (or ignore-active-transactions
  376.                   (null (dc-log-active-transactions dc-log)))
  377.         (cerror "Close the log anyway."
  378.                 "Attempt to close ~s with active transactions."
  379.                 dc-log))
  380.       (close-disk-cache (dc-log-disk-cache dc-log))
  381.       (setf (dc-log-disk-cache dc-log) nil
  382.             (dc-log-page dc-log) nil
  383.             (dc-log-buffer dc-log) nil
  384.             (dc-log-page-0 dc-log) nil
  385.             (dc-log-buffer-0 dc-log) nil)
  386.       t)))
  387.  
  388. ; Make a dc-log one block longer.
  389. ; Position the pointer at the beginning of the new block.
  390. ; return the position of the pointer.
  391. (defun log-extend (dc-log) 
  392.   (let* ((disk-cache (dc-log-disk-cache dc-log))
  393.          (page-size (disk-cache-page-size disk-cache))
  394.          (size (disk-cache-size disk-cache))
  395.          (old-page (dc-log-page dc-log)))
  396.     (unless (eql 0 (mod size page-size))
  397.       (error "Inconsistency: Log is not an even number of pages long"))
  398.     (extend-disk-cache disk-cache (+ size page-size))
  399.     (multiple-value-bind (buffer offset bytes-left page)
  400.                          (get-disk-page disk-cache size t)
  401.       (unless (and (eql offset 0) (eql bytes-left page-size))
  402.         (error "Inconsistent page offset stuff."))
  403.       (array-fill-byte buffer 0 0 bytes-left)
  404.       (lock-page page)
  405.       (when old-page
  406.         (when (dc-log-modified dc-log)
  407.           (mark-page-modified old-page)
  408.           (setf (dc-log-modified dc-log) nil))
  409.         (unlock-page old-page))
  410.       (setf (dc-log-page dc-log) page
  411.             (dc-log-buffer dc-log) buffer
  412.             (dc-log-ptr dc-log) 0
  413.             (dc-log-bytes-left dc-log) bytes-left))
  414.     size))
  415.  
  416. (defun log-next-page (dc-log &optional extend-p)
  417.   (let* ((page (dc-log-page dc-log))
  418.          (disk-cache (disk-page-disk-cache page))
  419.          (page-size (disk-cache-page-size disk-cache))
  420.          (address (+ (disk-page-address page) page-size)))
  421.     (declare (fixnum page-size))
  422.     (when (dc-log-modified dc-log)
  423.       (mark-page-modified page)
  424.       (setf (dc-log-modified dc-log) nil))
  425.     (multiple-value-bind (buf offset size new-page)
  426.                          (get-disk-page disk-cache address)
  427.       (declare (fixnum offset size))
  428.       (unless (or (eql offset 0) (eql offset page-size))
  429.         (error "Non-aligned log page in ~s" dc-log))
  430.       (unless (> size 0)
  431.         (if extend-p
  432.           (return-from log-next-page
  433.             (log-extend dc-log)))
  434.         (error "Attempt to read past eof of ~s" dc-log))
  435.       (lock-page new-page)
  436.       (setf (dc-log-page dc-log) new-page
  437.             (dc-log-buffer dc-log) buf
  438.             (dc-log-ptr dc-log) 0
  439.             (dc-log-bytes-left dc-log) size)
  440.       (unlock-page page))
  441.     address))
  442.  
  443. (defun log-read-byte (dc-log)
  444.   (unless (dc-log-p dc-log)
  445.     (setq dc-log (require-type dc-log 'dc-log)))
  446.   (locally (declare (optimize (speed 3) (safety 0)))
  447.     (let ((bytes-left (dc-log-bytes-left dc-log)))
  448.       (declare (fixnum bytes-left))
  449.       (when (<= bytes-left 0)
  450.         (log-next-page dc-log)
  451.         (setq bytes-left (dc-log-bytes-left dc-log)))
  452.       (let ((buf (dc-log-buffer dc-log))
  453.             (ptr (dc-log-ptr dc-log)))
  454.         (declare (fixnum ptr)
  455.                  (type (simple-array (unsigned-byte 8) (*)) buf))
  456.         (prog1
  457.           (aref buf ptr)
  458.           (setf (dc-log-ptr dc-log) (the fixnum (1+ ptr))
  459.                 (dc-log-bytes-left dc-log) (the fixnum (1- bytes-left))))))))
  460.  
  461. (defun log-read-word (dc-log)
  462.   (unless (dc-log-p dc-log)
  463.     (setq dc-log (require-type dc-log 'dc-log)))
  464.   (locally (declare (optimize (speed 3) (safety 0)))
  465.     (let ((bytes-left (dc-log-bytes-left dc-log)))
  466.       (declare (fixnum bytes-left))
  467.       (if (>= bytes-left 2)
  468.         (let ((buf (dc-log-buffer dc-log))
  469.               (ptr (dc-log-ptr dc-log)))
  470.           (declare (fixnum ptr)
  471.                    (type (simple-array (unsigned-byte 8) (*)) buf))
  472.           (prog1
  473.             (the fixnum
  474.               (+ (the fixnum (ash (the fixnum (aref buf ptr)) 8))
  475.                  (the fixnum (aref buf (incf ptr)))))
  476.             (setf (dc-log-ptr dc-log) (the fixnum (1+ ptr))
  477.                   (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 2)))))
  478.         (the fixnum
  479.           (+ (the fixnum (ash (the fixnum (log-read-byte dc-log)) 8))
  480.              (the fixnum (log-read-byte dc-log))))))))
  481.  
  482. (defun log-read-long (dc-log)
  483.   (unless (dc-log-p dc-log)
  484.     (setq dc-log (require-type dc-log 'dc-log)))
  485.   (locally (declare (optimize (speed 3) (safety 0)))
  486.     (let ((bytes-left (dc-log-bytes-left dc-log)))
  487.       (declare (fixnum bytes-left))
  488.       (macrolet ((add-em (b3 b2 b1 b0)
  489.                    `(let ((-b3- ,b3)
  490.                           (-low-3- (the fixnum
  491.                                      (+ (the fixnum (ash (the fixnum ,b2) 16))
  492.                                         (the fixnum (ash (the fixnum ,b1) 8))
  493.                                         (the fixnum ,b0)))))
  494.                       (if (eql 0 -b3-)
  495.                         -low-3-
  496.                         (+ (ash -b3- 24) -low-3-)))))
  497.         (if (>= bytes-left 4)
  498.           (let ((buf (dc-log-buffer dc-log))
  499.                 (ptr (dc-log-ptr dc-log)))
  500.             (declare (fixnum ptr)
  501.                      (type (simple-array (unsigned-byte 8) (*)) buf))
  502.             (prog1
  503.               (add-em (aref buf ptr)
  504.                       (aref buf (incf ptr))
  505.                       (aref buf (incf ptr))
  506.                       (aref buf (incf ptr)))
  507.               (setf (dc-log-ptr dc-log) (the fixnum (1+ ptr))
  508.                     (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4)))))
  509.           (add-em (log-read-byte dc-log)
  510.                   (log-read-byte dc-log)
  511.                   (log-read-byte dc-log)
  512.                   (log-read-byte dc-log)))))))
  513.  
  514. (defvar *log-pointer-buf*
  515.   (make-array 4 :element-type '(unsigned-byte 8)))
  516.  
  517. (defun log-read-pointer (dc-log)
  518.   (unless (dc-log-p dc-log)
  519.     (setq dc-log (require-type dc-log 'dc-log)))
  520.   (locally (declare (optimize (speed 3) (safety 0)))
  521.     (let ((pointer-buf (or *log-pointer-buf* 
  522.                            (make-array 4 :element-type '(unsigned-byte 8)))))
  523.       (declare (type (simple-array (unsigned-byte 8) (*)) pointer-buf))
  524.       (setq *log-pointer-buf* nil)
  525.       (let ((bytes-left (dc-log-bytes-left dc-log)))
  526.         (declare (fixnum bytes-left))
  527.         (if (>= bytes-left 4)
  528.           (let ((buf (dc-log-buffer dc-log))
  529.                 (ptr (dc-log-ptr dc-log)))
  530.             (declare (fixnum ptr)
  531.                      (type (simple-array (unsigned-byte 8) (*)) buf))
  532.             (setf (aref pointer-buf 0) (aref buf ptr)
  533.                   (aref pointer-buf 1) (aref buf (incf ptr))
  534.                   (aref pointer-buf 2) (aref buf (incf ptr))
  535.                   (aref pointer-buf 3) (aref buf (incf ptr))
  536.                   (dc-log-ptr dc-log) (the fixnum (1+ ptr))
  537.                   (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4))))
  538.           (setf (aref pointer-buf 0) (log-read-byte dc-log)
  539.                 (aref pointer-buf 1) (log-read-byte dc-log)
  540.                 (aref pointer-buf 2) (log-read-byte dc-log)
  541.                 (aref pointer-buf 3) (log-read-byte dc-log))))
  542.       (multiple-value-bind (res imm?) (%%load-pointer pointer-buf 0)
  543.         (setq *log-pointer-buf* pointer-buf)
  544.         (values res imm?)))))
  545.  
  546. (defun log-write-byte (dc-log byte)
  547.   (unless (fixnump byte)
  548.     (setq byte (require-type byte 'fixnum)))
  549.   (unless (dc-log-p dc-log)
  550.     (setq dc-log (require-type dc-log 'dc-log)))
  551.   (locally (declare (optimize (speed 3) (safety 0))
  552.                     (fixnum byte))
  553.     (let ((bytes-left (dc-log-bytes-left dc-log)))
  554.       (declare (fixnum bytes-left))
  555.       (when (<= bytes-left 0)
  556.         (log-next-page dc-log t)
  557.         (setq bytes-left (dc-log-bytes-left dc-log)))
  558.       (let ((buf (dc-log-buffer dc-log))
  559.             (ptr (dc-log-ptr dc-log)))
  560.         (declare (fixnum ptr)
  561.                  (type (simple-array (unsigned-byte 8) (*)) buf))
  562.         (setf (aref buf ptr) byte
  563.               (dc-log-ptr dc-log) (the fixnum (1+ ptr))
  564.               (dc-log-bytes-left dc-log) (the fixnum (1- bytes-left))
  565.               (dc-log-modified dc-log) t)
  566.         byte))))
  567.  
  568. (defun log-write-word (dc-log word)
  569.   (unless (fixnump word)
  570.     (setq word (require-type word 'fixnum)))
  571.   (unless (dc-log-p dc-log)
  572.     (setq dc-log (require-type dc-log 'dc-log)))
  573.   (locally (declare (optimize (speed 3) (safety 0))
  574.                     (fixnum word))
  575.     (let ((bytes-left (dc-log-bytes-left dc-log)))
  576.       (declare (fixnum bytes-left))
  577.       (if (>= bytes-left 2)
  578.         (let ((buf (dc-log-buffer dc-log))
  579.               (ptr (dc-log-ptr dc-log)))
  580.           (declare (fixnum ptr)
  581.                    (type (simple-array (unsigned-byte 8) (*)) buf))
  582.           (setf (aref buf ptr) (ash word -8)
  583.                 (aref buf (the fixnum (1+ ptr))) (logand word #xff)
  584.                 (dc-log-ptr dc-log) (the fixnum (+ ptr 2))
  585.                 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 2))
  586.                 (dc-log-modified dc-log) t))
  587.         (progn
  588.           (log-write-byte dc-log (ash word -8))
  589.           (log-write-byte dc-log (logand word #xff))))
  590.       word)))
  591.  
  592. (defun log-write-long (dc-log long)
  593.   (setq long (require-type long 'integer))
  594.   (unless (dc-log-p dc-log)
  595.     (setq dc-log (require-type dc-log 'dc-log)))
  596.   (locally (declare (optimize (speed 3) (safety 0)))
  597.     (let ((bytes-left (dc-log-bytes-left dc-log))
  598.           (low3 (if (fixnump long)
  599.                   (the fixnum (logand (the fixnum long) #xffffff))
  600.                   (logand long #xffffff))))
  601.       (declare (fixnum bytes-left low3))
  602.       (if (>= bytes-left 4)
  603.         (let ((buf (dc-log-buffer dc-log))
  604.               (ptr (dc-log-ptr dc-log)))
  605.           (declare (fixnum ptr)
  606.                    (type (simple-array (unsigned-byte 8) (*)) buf))
  607.           (setf (aref buf ptr) (if (eql low3 long) 0 (ash long -24))
  608.                 (aref buf (incf ptr)) (ash low3 -16)
  609.                 (aref buf (incf ptr)) (logand (ash low3 -8) #xff)
  610.                 (aref buf (incf ptr)) (logand low3 #xff)
  611.                 (dc-log-ptr dc-log) (the fixnum (1+ ptr))
  612.                 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4))
  613.                 (dc-log-modified dc-log) t))
  614.         (progn
  615.           (log-write-byte dc-log (if (eql low3 long) 0 (ash long -24)))
  616.           (log-write-byte dc-log (ash low3 -16))
  617.           (log-write-byte dc-log (logand (ash low3 -8) #xff))
  618.           (log-write-byte dc-log (logand low3 #xff))))
  619.       long)))
  620.  
  621. (defun log-write-pointer (dc-log pointer &optional imm?)
  622.   (unless (dc-log-p dc-log)
  623.     (setq dc-log (require-type dc-log 'dc-log)))
  624.   (locally (declare (optimize (speed 3) (safety 0)))
  625.     (let ((pointer-buf (or *log-pointer-buf* 
  626.                            (make-array 4 :element-type '(unsigned-byte 8)))))
  627.       (declare (type (simple-array (unsigned-byte 8) (*)) pointer-buf))
  628.       (setq *log-pointer-buf* nil)
  629.       (%%store-pointer pointer pointer-buf 0 imm?)
  630.       (let ((bytes-left (dc-log-bytes-left dc-log)))
  631.         (declare (fixnum bytes-left))
  632.         (if (>= bytes-left 4)
  633.           (let ((buf (dc-log-buffer dc-log))
  634.                 (ptr (dc-log-ptr dc-log)))
  635.             (declare (fixnum ptr)
  636.                      (type (simple-array (unsigned-byte 8) (*)) buf))
  637.             (setf (aref buf ptr) (aref pointer-buf 0)
  638.                   (aref buf (incf ptr)) (aref pointer-buf 1)
  639.                   (aref buf (incf ptr)) (aref pointer-buf 2)
  640.                   (aref buf (incf ptr)) (aref pointer-buf 3)
  641.                   (dc-log-ptr dc-log) (the fixnum (1+ ptr))
  642.                   (dc-log-bytes-left dc-log) (the fixnum (- bytes-left 4))
  643.                   (dc-log-modified dc-log) t))
  644.           (progn
  645.             (log-write-byte dc-log (aref pointer-buf 0))
  646.             (log-write-byte dc-log (aref pointer-buf 1))
  647.             (log-write-byte dc-log (aref pointer-buf 2))
  648.             (log-write-byte dc-log (aref pointer-buf 3)))))
  649.       (values pointer imm?))))
  650.  
  651. (defun log-read-length (dc-log)
  652.   (let ((res 0)
  653.         (byte 0))
  654.     (declare (fixnum res byte))
  655.     (loop
  656.       (setq byte (log-read-byte dc-log))
  657.       (if (logbitp 7 byte)
  658.         (setq res (+ (the fixnum (ash res 8)) (logand #x7f byte)))
  659.         (return (the fixnum (+ (the fixnum (ash res 8)) byte)))))))
  660.  
  661. (defun log-write-length (dc-log length)
  662.   (unless (fixnump length)
  663.     (setq length (require-type length 'fixnum)))
  664.   (labels ((foo (dc-log length hibit)
  665.              (declare (fixnum length hibit)
  666.                       (optimize (speed 3) (safety 0)))
  667.              (if (>= length 128)
  668.                (progn
  669.                  (foo dc-log (ash length -7) 128)
  670.                  (log-write-byte dc-log (logior hibit (logand length #x7f))))
  671.                (log-write-byte dc-log (logior hibit length)))))
  672.     (foo dc-log length 0)))
  673.  
  674. ; Will read a length from the log if the END arg is omitted.
  675. ; If STRING is specified, it can be any 1-d array capable of holding
  676. ; bytes (same limitations as %copy-byte-array-portion)
  677. ; If STRING is not specified, will cons up a string.
  678. (defun log-read-string (dc-log &optional string (start 0) length)
  679.   (unless (fixnump start)
  680.     (setq start (require-type start 'fixnum)))
  681.   (if length
  682.     (setq length (require-type length 'fixnum)))
  683.   (unless (dc-log-p dc-log)
  684.     (setq dc-log (require-type dc-log 'dc-log)))
  685.   (locally (declare (fixnum start)
  686.                     (optimize (speed 3) (safety 0)))
  687.     (let ((length (or length (log-read-length dc-log)))
  688.           (buf (dc-log-buffer dc-log))
  689.           (ptr (dc-log-ptr dc-log))
  690.           (bytes-left (dc-log-bytes-left dc-log)))
  691.       (declare (fixnum length ptr bytes-left))
  692.       (unless string (setq string (make-string length)))
  693.       (unless (<= length 0)
  694.         (if (<= bytes-left 0)
  695.           (log-next-page dc-log))
  696.         (loop
  697.           (let ((bytes-to-move (if (< bytes-left length) bytes-left length)))
  698.             (declare (fixnum bytes-to-move))
  699.             (%copy-byte-array-portion buf ptr bytes-to-move string start)
  700.             (when (<= (decf length bytes-to-move) 0)
  701.               (setf (dc-log-ptr dc-log) (the fixnum (+ ptr bytes-to-move))
  702.                     (dc-log-bytes-left dc-log) (the fixnum (- bytes-left bytes-to-move)))
  703.               (return))
  704.             (incf start bytes-to-move)
  705.             (log-next-page dc-log)
  706.             (setq buf (dc-log-buffer dc-log)
  707.                   ptr (dc-log-ptr dc-log)
  708.                   bytes-left (dc-log-bytes-left dc-log)))))
  709.       string)))
  710.  
  711. ; Again, STRING is as for %copy-byte-array-portion
  712. (defun log-write-string (dc-log string write-length? &optional
  713.                                 (start 0) length)
  714.   (let ((string-length (length string)))
  715.     (declare (fixnum string-length))
  716.     (setq start (require-type start 'fixnum))
  717.     (unless (<= 0 start string-length)
  718.       (error "~s not inside string" 'start))
  719.     (locally (declare (fixnum start))
  720.       (if length
  721.         (progn
  722.           (setq length (require-type length 'fixnum))
  723.           (locally (declare (fixnum length))
  724.             (unless (<= start (+ start length) string-length)
  725.               (error "(+ ~s ~s) not inside string" 'start 'length))))
  726.         (setq length (- string-length start)))))
  727.   (unless (dc-log-p dc-log)
  728.     (setq dc-log (require-type dc-log 'dc-log)))
  729.   (locally (declare (fixnum start length)
  730.                     (optimize (speed 3) (safety 0)))
  731.     (when write-length?
  732.       (log-write-length dc-log length))
  733.     (when (> length 0)
  734.       (let ((buf (dc-log-buffer dc-log))
  735.             (ptr (dc-log-ptr dc-log))
  736.             (bytes-left (dc-log-bytes-left dc-log)))
  737.         (declare (fixnum ptr bytes-left))
  738.         (loop
  739.           (let ((bytes-to-write (if (< bytes-left length) bytes-left length)))
  740.             (declare (fixnum bytes-to-write))
  741.             (%copy-byte-array-portion string start bytes-to-write buf ptr)
  742.             (when (<= (decf length bytes-to-write) 0)
  743.               (setf (dc-log-ptr dc-log) (the fixnum (+ ptr bytes-to-write))
  744.                     (dc-log-bytes-left dc-log) (the fixnum (- bytes-left bytes-to-write)))
  745.               (return))
  746.             (incf start bytes-to-write)
  747.             (setf (dc-log-modified dc-log) t)
  748.             (log-next-page dc-log t)
  749.             (setq buf (dc-log-buffer dc-log)
  750.                   ptr (dc-log-ptr dc-log)
  751.                   bytes-left (dc-log-bytes-left dc-log)))))))
  752.   string)
  753.  
  754. (defun log-write-disk-cache-portion (dc-log address length)
  755.   (setq length (require-type length 'fixnum))
  756.   (locally (declare (fixnum length))
  757.     (let ((disk-cache (dc-log-log-for dc-log))
  758.           (buf (make-string 512))
  759.           (bytes-to-copy 0))
  760.       (declare (fixnum bytes-to-copy offset bytes-left))
  761.       (declare (dynamic-extent string))
  762.       (unless (<= length 0)
  763.         (loop
  764.           (with-locked-page (disk-cache address nil page-buf offset bytes-left)
  765.             (declare (fixnum offset bytes-left))
  766.             (setq bytes-to-copy 512)
  767.             (if (< bytes-left bytes-to-copy)
  768.               (setq bytes-to-copy bytes-left))
  769.             (if (< length bytes-to-copy)
  770.               (setq bytes-to-copy length))
  771.             (%copy-byte-array-portion page-buf offset bytes-to-copy buf 0))
  772.           (log-write-string dc-log buf nil 0 bytes-to-copy)
  773.           (if (<= (decf length bytes-to-copy) 0)
  774.             (return))
  775.           (incf address bytes-to-copy))))))
  776.  
  777. (defun log-read-disk-cache-portion (dc-log address length)
  778.   (setq length (require-type length 'fixnum))
  779.   (locally (declare (fixnum length))
  780.     (let ((disk-cache (dc-log-log-for dc-log))
  781.           (buf (make-string 512))
  782.           (bytes-to-copy 0))
  783.       (declare (fixnum bytes-to-copy))
  784.       (declare (dynamic-extent string))
  785.       (unless (<= length 0)
  786.         (loop
  787.           (with-locked-page (disk-cache address t page-buf offset bytes-left)
  788.             (declare (fixnum offset bytes-left))
  789.             (setq bytes-to-copy 512)
  790.             (if (< bytes-left bytes-to-copy)
  791.               (setq bytes-to-copy bytes-left))
  792.             (if (< length bytes-to-copy)
  793.               (setq bytes-to-copy length))
  794.             (log-read-string dc-log buf 0 bytes-to-copy)
  795.             (%copy-byte-array-portion buf offset bytes-to-copy page-buf 0)
  796.             (if (<= (decf length bytes-to-copy) 0)
  797.               (return))
  798.             (incf address bytes-to-copy)))))))
  799.  
  800. (defun log-position (dc-log &optional new-position)
  801.   (let* ((page (dc-log-page dc-log))
  802.          (pos (if page
  803.                 (+ (disk-page-address page) (dc-log-ptr dc-log))
  804.                 0))
  805.          (disk-cache (dc-log-disk-cache dc-log)))
  806.     (if (null new-position)
  807.       pos
  808.       (let ((eof (dc-log-eof dc-log))
  809.             (offset 0))
  810.         (declare (fixnum offset))
  811.         (if (> pos eof)
  812.           (setq eof (setf (dc-log-eof dc-log) pos)))
  813.         (if (> new-position eof)
  814.           (error "Attempt to set position past EOF"))
  815.         (when (eql new-position (disk-cache-size disk-cache))
  816.           (setq offset 1)
  817.           (decf new-position))
  818.         (when (dc-log-modified dc-log)
  819.           (mark-page-modified page)
  820.           (setf (dc-log-modified dc-log) nil))
  821.         (multiple-value-bind (buf ptr bytes-left new-page)
  822.                              (get-disk-page disk-cache new-position)
  823.           (declare (fixnum ptr bytes-left))
  824.           (unless (eq page new-page)
  825.             (lock-page new-page)
  826.             (setf (dc-log-page dc-log) new-page
  827.                   (dc-log-buffer dc-log) buf)
  828.             (when page (unlock-page page)))
  829.           (setf (dc-log-ptr dc-log) (the fixnum (+ ptr offset))
  830.                 (dc-log-bytes-left dc-log) (the fixnum (- bytes-left offset))))
  831.           new-position))))
  832.  
  833. (defun force-log (dc-log)
  834.   (let* ((buf-0 (dc-log-buffer-0 dc-log))
  835.          (old-eof (%load-long buf-0 $log-eof-address))
  836.          (eof (max (dc-log-eof dc-log) (log-position dc-log))))
  837.     (unless (eql eof old-eof)
  838.       (%store-long eof buf-0 $log-eof-address)
  839.       (mark-page-modified (dc-log-page-0 dc-log)))
  840.     (when (dc-log-modified dc-log)
  841.       (mark-page-modified (dc-log-page dc-log))
  842.       (setf (dc-log-modified dc-log) nil))
  843.     (flush-disk-cache (dc-log-disk-cache dc-log))))
  844.  
  845. #|
  846. Begin transaction:
  847. =========
  848. $begin-transaction-type          ; <byte>
  849. <parent LSN>                     ; <long> - LSN of parent transaction or 0
  850. =========
  851. |#
  852. ; Returns the LSN of the new transaction
  853. (defun begin-transaction-log-entry (dc-log &optional (parent-lsn 0))
  854.   (setq parent-lsn (require-type parent-lsn 'integer))
  855.   (let ((lsn (log-position dc-log)))
  856.     (log-write-byte dc-log $begin-transaction-type)
  857.     (log-write-long dc-log parent-lsn)
  858.     (push lsn (dc-log-active-transactions dc-log))
  859.     lsn))
  860.  
  861. #|
  862. Continue transaction.
  863. A Continue transaction record is written when a different
  864. transaction needs to write log records.
  865. =========
  866. $continue-transaction-type       ; <byte>
  867. <LSN>                            ; <long>
  868. =========
  869. |#
  870. (defun log-ensure-active-transaction (dc-log transaction-lsn)
  871.   (unless (member transaction-lsn (dc-log-active-transactions dc-log))
  872.     (error "~s is not an active transaction of ~s" transaction-lsn dc-log)))
  873.  
  874. (defun continue-transaction-log-entry (dc-log transaction-lsn)
  875.   (log-ensure-active-transaction dc-log transaction-lsn)
  876.   (log-write-byte dc-log $continue-transaction-type)
  877.   (log-write-long dc-log transaction-lsn))
  878.  
  879. #|
  880. Abort transaction:
  881. =========
  882. $abort-transaction-type          ; <byte>
  883. <LSN>                            ; <long>
  884. =========
  885. |#
  886. (defun abort-transaction-log-entry (dc-log transaction-lsn)
  887.   (log-ensure-active-transaction dc-log transaction-lsn)
  888.   (setf (dc-log-active-transactions dc-log)
  889.         (delete transaction-lsn (dc-log-active-transactions dc-log)))
  890.   (log-write-byte dc-log $abort-transaction-type)
  891.   (log-write-long dc-log transaction-lsn))
  892.   
  893.  
  894. #|
  895. Commit transaction:
  896. =========
  897. $commit-transaction-type         ; <byte>
  898. <LSN>                            ; <long>
  899. =========
  900. |#
  901. (defun commit-transaction-log-entry (dc-log transaction-lsn)
  902.   (log-ensure-active-transaction dc-log transaction-lsn)
  903.   (setf (dc-log-active-transactions dc-log)
  904.         (delete transaction-lsn (dc-log-active-transactions dc-log)))
  905.   (log-write-byte dc-log $commit-transaction-type)
  906.   (log-write-long dc-log transaction-lsn))
  907.  
  908. #|
  909. Checkpoint:
  910. =========
  911. $checkpoint-type                 ; <byte>
  912. <open transaction count>         ; <length>
  913. <lsn 0>                          ; <long>
  914. ...
  915. <lsn n>                          ; <long>
  916. =========
  917. |#
  918. (defun checkpoint-log-entry (dc-log)
  919.   (let* ((lsn (log-position dc-log))
  920.          (active-transactions (dc-log-active-transactions dc-log))
  921.          (count (length active-transactions)))
  922.     (log-write-byte dc-log $checkpoint-type)
  923.     (log-write-length dc-log count)
  924.     (dolist (lsn active-transactions)
  925.       (log-write-long dc-log lsn))
  926.     (%store-long lsn (dc-log-buffer-0 dc-log) $log-checkpoint-address)
  927.     (mark-page-modified (dc-log-page-0 dc-log))
  928.     count))
  929.  
  930. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  931. ;;
  932. ;; The undoable log entries each have an undo function.
  933. ;; This function is called by undo-aborted-transaction with two args:
  934. ;; a log positioned just after the <undo-link> and the disk-cache
  935. ;; we're logging.
  936. ;;
  937.  
  938. #|
  939. Write byte:
  940. =========
  941. $write-byte                      ; <byte>
  942. <address>                        ; <long>
  943. <data>                           ; <byte>
  944. =========
  945.  
  946. Write byte with undo:
  947. =========
  948. $write-byte-with-undo            ; <byte>
  949. <undo-link)                      ; <length>
  950. <address>                        ; <long>
  951. <old data>                       ; <byte>
  952. <new data>                       ; <byte>
  953. =========
  954. |#
  955.  
  956. (defun write-byte-log-entry (dc-log address byte &optional last-undo)
  957.   (if last-undo
  958.     (progn
  959.       (log-write-byte dc-log $write-byte-with-undo)
  960.       (log-write-length dc-log (- (log-position dc-log) last-undo))
  961.       (log-write-long dc-log address)
  962.       (log-write-byte dc-log (read-8-bits (dc-log-disk-cache dc-log) address)))
  963.     (progn
  964.       (log-write-byte dc-log $write-byte)
  965.       (log-write-long dc-log address)))
  966.   (log-write-byte dc-log byte))
  967.  
  968. (defun undo-write-byte (log disk-cache)
  969.   (setf (read-8-bits disk-cache (log-read-long log)) (log-read-byte log)))
  970.  
  971. #|
  972. Write word:
  973. =========
  974. $write-word                      ; <byte>
  975. <address>                        ; <long>
  976. <data>                           ; <word>
  977. =========
  978.  
  979. Write word with undo:
  980. =========
  981. $write-word-with-undo            ; <byte>
  982. <undo-link)                      ; <length>
  983. <address>                        ; <long>
  984. <old data>                       ; <word>
  985. <new data>                       ; <word>
  986. =========
  987. |#
  988.  
  989. (defun write-word-log-entry (dc-log address word &optional last-undo)
  990.   (if last-undo
  991.     (progn
  992.       (log-write-byte dc-log $write-word-with-undo)
  993.       (log-write-length dc-log (- (log-position dc-log) last-undo))
  994.       (log-write-long dc-log address)
  995.       (log-write-word dc-log (read-word (dc-log-disk-cache dc-log) address)))
  996.     (progn
  997.       (log-write-byte dc-log $write-word)
  998.       (log-write-long dc-log address)))
  999.   (log-write-word dc-log word))
  1000.  
  1001. (defun undo-write-word (log disk-cache)
  1002.   (setf (read-word disk-cache (log-read-long log)) (log-read-word log)))
  1003.  
  1004. #|
  1005. Write long:
  1006. =========
  1007. $write-long                      ; <byte>
  1008. <address>                        ; <long>
  1009. <data>                           ; <long>
  1010. =========
  1011.  
  1012. Write long with undo:
  1013. =========
  1014. $write-long-with-undo            ; <byte>
  1015. <undo-link)                      ; <length>
  1016. <address>                        ; <long>
  1017. <old data>                       ; <long>
  1018. <new data>                       ; <long>
  1019. =========
  1020. |#
  1021.  
  1022. (defun write-long-log-entry (dc-log address long &optional imm? last-undo)
  1023.   (if last-undo
  1024.     (progn
  1025.       (log-write-byte dc-log $write-byte-with-undo)
  1026.       (log-write-length dc-log (- (log-position dc-log) last-undo))
  1027.       (log-write-long dc-log address)
  1028.       (log-write-long dc-log (read-long (dc-log-disk-cache dc-log) address)))
  1029.     (progn
  1030.       (log-write-byte dc-log $write-long)
  1031.       (log-write-long dc-log address)))
  1032.   (if imm?
  1033.     (log-write-pointer dc-log long t)
  1034.     (log-write-long dc-log long)))
  1035.  
  1036. (defun undo-write-long (log disk-cache)
  1037.   (setf (read-long disk-cache (log-read-long log)) (log-read-long log)))
  1038.  
  1039. #|
  1040. Write bytes:
  1041. =========
  1042. $write-bytes                     ; <byte>
  1043. <address>                        ; <long>
  1044. <size>                           ; <length>
  1045. <data>                           ; <size> <byte>s
  1046. =========
  1047.  
  1048. write bytes with undo:
  1049. =========
  1050. $write-bytes-with-undo           ; <byte>
  1051. <undo-link>                      ; <length>
  1052. <address>                        ; <long>
  1053. <size>                           ; <length>
  1054. <old data>                       ; <size> <byte>s
  1055. <new data>                       ; <size> <byte>s
  1056. =========
  1057. |#
  1058. (defun write-bytes-log-entry (dc-log string start length address &optional last-undo)
  1059.   (if last-undo
  1060.     (progn
  1061.       (log-write-byte dc-log $write-bytes-with-undo)
  1062.       (log-write-length dc-log (- (log-position dc-log) last-undo))
  1063.       (log-write-long dc-log address)
  1064.       (log-write-length dc-log length)
  1065.       (log-write-disk-cache-portion dc-log address length)
  1066.       (log-write-string dc-log string nil start length))
  1067.     (progn
  1068.       (log-write-byte dc-log $write-bytes)
  1069.       (log-write-long dc-log address)
  1070.       (log-write-string dc-log string t start length)))
  1071.   string)
  1072.  
  1073. (defun undo-write-bytes (log disk-cache)
  1074.   (declare (ignore disk-cache))
  1075.   (log-read-disk-cache-portion log (log-read-long log) (log-read-length log)))
  1076.  
  1077. #|
  1078. Fill bytes:
  1079. =========
  1080. $fill-byte                      ; <byte>
  1081. <address>                        ; <long>
  1082. <count>                          ; <length>
  1083. <data>                           ; <byte>
  1084. =========
  1085.  
  1086. Fill bytes with undo:
  1087. =========
  1088. $fill-byte-with-undo            ; <byte>
  1089. <undo-link>                      ; <length>
  1090. <address>                        ; <long>
  1091. <count>                          ; <length>
  1092. <old data>                       ; <count> <byte>s
  1093. <new data>                       ; <byte>
  1094. =========
  1095. |#
  1096. (defun fill-byte-log-entry (dc-log address value count &optional last-undo)
  1097.   (if last-undo
  1098.     (progn
  1099.       (log-write-byte dc-log $fill-byte-with-undo)
  1100.       (log-write-length dc-log (- (log-position dc-log) last-undo))
  1101.       (log-write-long dc-log address)
  1102.       (log-write-length dc-log count)
  1103.       (log-write-disk-cache-portion dc-log address count))
  1104.     (progn
  1105.       (log-write-byte dc-log $fill-byte)
  1106.       (log-write-long dc-log address)
  1107.       (log-write-length dc-log count)))
  1108.   (log-write-byte dc-log value))
  1109.  
  1110. (defun undo-fill-byte (log disk-cache)
  1111.   (declare (ignore disk-cache))
  1112.   (log-read-disk-cache-portion log (log-read-long log) (log-read-length log)))
  1113.  
  1114. #|
  1115. Fill word:
  1116. =========
  1117. $fill-word                       ; <byte>
  1118. <address>                        ; <long>
  1119. <count>                          ; <length>
  1120. <data>                           ; <word>
  1121. =========
  1122.  
  1123. Fill word with undo:
  1124. =========
  1125. $fill-word-with-undo             ; <byte>
  1126. <undo-link>                      ; <length>
  1127. <address>                        ; <long>
  1128. <count>                          ; <length>
  1129. <old data>                       ; <count> <word>s
  1130. <new data>                       ; <word>
  1131. =========
  1132. |#
  1133. (defun fill-word-log-entry (dc-log address value count &optional last-undo)
  1134.   (if last-undo
  1135.     (progn
  1136.       (log-write-byte dc-log $fill-word-with-undo)
  1137.       (log-write-length dc-log (- (log-position dc-log) last-undo))
  1138.       (log-write-long dc-log address)
  1139.       (log-write-length dc-log count)
  1140.       (log-write-disk-cache-portion dc-log address count))
  1141.     (progn
  1142.       (log-write-byte dc-log $fill-word)
  1143.       (log-write-long dc-log address)
  1144.       (log-write-length dc-log count)))
  1145.   (log-write-word dc-log value))
  1146.  
  1147. (defun undo-fill-word (log disk-cache)
  1148.   (declare (ignore disk-cache))
  1149.   (log-read-disk-cache-portion 
  1150.    log (log-read-long log) (* 2 (the fixnum (log-read-length log)))))
  1151.  
  1152. #|
  1153. Fill long:
  1154. =========
  1155. $fill-long                       ; <byte>
  1156. <address>                        ; <long>
  1157. <count>                          ; <length>
  1158. <data>                           ; <long>
  1159. =========
  1160.  
  1161. Fill long with undo:
  1162. =========
  1163. $fill-long-with-undo             ; <byte>
  1164. <undo-link>                      ; <length>
  1165. <address>                        ; <long>
  1166. <count>                          ; <length>
  1167. <old data>                       ; <count> <long>s
  1168. <new data>                       ; <long>
  1169. =========
  1170. |#
  1171. (defun fill-long-log-entry (dc-log address value count &optional imm? last-undo)
  1172.   (if last-undo
  1173.     (progn
  1174.       (log-write-byte dc-log $fill-long-with-undo)
  1175.       (log-write-length dc-log (- (log-position dc-log) last-undo))
  1176.       (log-write-long dc-log address)
  1177.       (log-write-length dc-log count)
  1178.       (log-write-disk-cache-portion dc-log address count))
  1179.     (progn
  1180.       (log-write-byte dc-log $fill-long)
  1181.       (log-write-long dc-log address)
  1182.       (log-write-length dc-log count)))
  1183.   (if imm?
  1184.     (log-write-pointer dc-log value t)
  1185.     (log-write-long dc-log value)))
  1186.  
  1187. (defun undo-fill-long (log disk-cache)
  1188.   (declare (ignore disk-cache))
  1189.   (log-read-disk-cache-portion 
  1190.    log (log-read-long log) (* 4 (the fixnum (log-read-length log)))))
  1191.  
  1192. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1193. ;;
  1194. ;; Support for undoing aborted transactions
  1195. ;;
  1196.  
  1197. (eval-when (:compile-toplevel :execute)
  1198.   (require "LISPEQU"))                  ; ccl::%cons-pool & ccl::pool.data
  1199.  
  1200. (defvar *dc-log-resource* (ccl::%cons-pool))
  1201.  
  1202. (defun allocate-dc-log ()
  1203.   (let ((log (ccl::pool.data *dc-log-resource*)))
  1204.     (if log
  1205.       (progn
  1206.         (setf (ccl::pool.data *dc-log-resource*)
  1207.               (dc-log-log-for log))
  1208.         (setf (dc-log-log-for log) nil)
  1209.         log)
  1210.       (make-dc-log))))
  1211.  
  1212. ; The reason we copy a log is so that recovery can use it as a pointer.
  1213. ; We need to lock the page a second time so that it remains locked
  1214. ; when we move to a different page with either log.
  1215. (defun dc-log-copy (log)
  1216.   (let ((copy (allocate-dc-log))
  1217.         (page (dc-log-page log)))
  1218.     (setf (dc-log-log-for copy) (dc-log-log-for log)
  1219.           (dc-log-disk-cache copy) (dc-log-disk-cache log)
  1220.           (dc-log-page copy) page
  1221.           (dc-log-buffer copy) (dc-log-buffer log)
  1222.           (dc-log-ptr copy) (dc-log-ptr log)
  1223.           (dc-log-bytes-left copy) (dc-log-bytes-left log)
  1224.           (dc-log-modified copy) (dc-log-modified log)
  1225.           (dc-log-page-0 copy) (dc-log-page-0 log)
  1226.           (dc-log-buffer-0 copy) (dc-log-buffer-0 log)
  1227.           (dc-log-eof copy) (dc-log-eof log)
  1228.           (dc-log-active-transactions copy) (dc-log-active-transactions log))
  1229.     (when page (lock-page page))
  1230.     copy))
  1231.  
  1232. (defun free-dc-log (log)
  1233.   (let ((page (dc-log-page log)))
  1234.     (when page
  1235.       (unlock-page page)))
  1236.   (setf (dc-log-disk-cache log) nil
  1237.         (dc-log-page log) nil
  1238.         (dc-log-buffer log) nil
  1239.         (dc-log-ptr log) 0
  1240.         (dc-log-bytes-left log) 0
  1241.         (dc-log-modified log) nil
  1242.         (dc-log-page-0 log) nil
  1243.         (dc-log-buffer-0 log) nil
  1244.         (dc-log-eof log) 0
  1245.         (dc-log-active-transactions log) nil)
  1246.   (let ((pool *dc-log-resource*))
  1247.     (setf (dc-log-log-for log) (ccl::pool.data pool)
  1248.           (ccl::pool.data pool) log))
  1249.   nil)
  1250.  
  1251. (defmacro with-dc-log-copy ((copy log) &body body)
  1252.   `(let ((,copy (dc-log-copy ,log)))
  1253.      (unwind-protect
  1254.        (progn ,@body)
  1255.        (free-dc-log ,copy))))
  1256.  
  1257. ;; last-undo is 0 if there's nothing to do.
  1258. ;; Otherwise, it's the LSN of the last undoable log entry for
  1259. ;; the transaction whose begin-transaction log entry is at LSN.
  1260. (defun undo-aborted-transaction (dc-log lsn last-undo)
  1261.   (with-dc-log-copy (log dc-log)
  1262.     (log-position log lsn)
  1263.     (let ((undo-ptr last-undo)
  1264.           (log-for (dc-log-log-for log)))
  1265.       (loop
  1266.         (if (eql 0 undo-ptr) (return))
  1267.         (log-position log undo-ptr)
  1268.         (let* ((type (log-read-byte log))
  1269.                (undo-function (svref *log-undo-functions* type)))
  1270.           (unless undo-function
  1271.             (error "Log entry ~s is not undoable" (log-type->name type)))
  1272.           (let ((undo-link (log-read-length log)))
  1273.             (decf undo-ptr undo-link))
  1274.           (funcall undo-function log log-for))))))
  1275.  
  1276. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1277. ;;
  1278. ;; tables
  1279. ;;
  1280. (defparameter *log-type->name*
  1281.   #(nil
  1282.     $begin-transaction-type             ; 1
  1283.     $continue-transaction-type          ; 2
  1284.     $abort-transaction-type             ; 3
  1285.     $commit-transaction-type            ; 4
  1286.     $write-byte                         ; 5
  1287.     $write-byte-with-undo               ; 6
  1288.     $write-word                         ; 7
  1289.     $write-word-with-undo               ; 8
  1290.     $write-long                         ; 9
  1291.     $write-long-with-undo               ; 10
  1292.     $write-bytes                        ; 11
  1293.     $write-bytes-with-undo              ; 12
  1294.     $fill-byte                          ; 13
  1295.     $fill-byte-with-undo                ; 14
  1296.     $fill-word                          ; 15
  1297.     $fill-word-with-undo                ; 16
  1298.     $fill-long                          ; 17
  1299.     $fill-long-with-undo                ; 18
  1300.     $checkpoint-type                    ; 19
  1301.     ))
  1302.  
  1303. (defparameter *log-undo-functions*
  1304.   #(nil                                 ; type 0 unused
  1305.     nil                                 ; $begin-transaction-type = 1
  1306.     nil                                 ; $continue-transaction-type = 2
  1307.     nil                                 ; $abort-transaction-type = 3
  1308.     nil                                 ; $commit-transaction-type = 4
  1309.     nil                                 ; $write-byte = 5
  1310.     undo-write-byte                     ; $write-byte-with-undo = 6
  1311.     nil                                 ; $write-word = 7
  1312.     undo-write-word                     ; $write-word-with-undo = 8
  1313.     nil                                 ; $write-long = 9
  1314.     undo-write-long                     ; $write-long-with-undo = 10
  1315.     nil                                 ; $write-bytes = 11
  1316.     undo-write-bytes                    ; $write-bytes-with-undo = 12
  1317.     nil                                 ; $fill-byte = 13
  1318.     undo-fill-byte                      ; $fill-byte-with-undo = 14
  1319.     nil                                 ; $fill-word = 15
  1320.     undo-fill-word                      ; $fill-word-with-undo = 16
  1321.     nil                                 ; $fill-long = 17
  1322.     undo-fill-long                      ; $fill-long-with-undo = 18
  1323.     nil                                 ; $checkpoint-type = 19
  1324.     ))
  1325.